# global variable to generate distinct names
glade.counter <- 0
glade.newName <- function(pattern, ext=""){
  glade.counter <<- glade.counter+1;
  return(paste(pattern, glade.counter, ext, sep=""));
}

setClass("glade",
         representation(piggy = "character", # the Piggy program
                        topObj = "character", # the top object this program defines
                        server = "character",
                        user = "character",
                        schema = "data.frame"));

# function to evaluate .() constructs
# works only if argument is parse tree
# the following code is "borrowed" from the definition of bquote
unquote <- function(e) {
  if (length(e) <= 1L)
    return(e)
  else if (e[[1L]] == as.name(".")) 
    return(eval(e[[2L]]))
  else return(as.call(lapply(e, unquote)))
}

# helper functions

# deparse but remove % in %..%
# this translates from the R to other languages subpart acces
deparse.clean <- function(expr,...){
  glade.optrans.tbl <- list( "$"="%.%" ); # translation table
           
  glade.optrans <- function(e){
    if (length(e) <= 1L)
      return(e)
    else {
      rep <- glade.optrans.tbl[[ as.character(e[[1L]]) ]];
      if (is.null(rep))
        rep <- as.character(e[[1L]]); # keep same if translation failed
      tail <- lapply(as.list(e)[-1L], glade.optrans); # transform recursively
      return(as.call(append(as.name(rep), tail)));
    }
  }

  return(gsub("%%","%",gsub(" %([^%]+)% ", "\\1",
                            deparse(glade.optrans(expr),...))));
}

# transform any input (string, parse tree, etc) into string
# WARNING: This function is limited to inputs of size 500L
# thank deparse for the limitation
# deparse produces multiple lines and paste does not like that
glade.normalize <- function(input) {
  input <- unquote(input);
  if (is.character(input))
    return(input);

  if (is.list(input))
    return( lapply(input, glade.normalize) );
  
  if (is.call(input) && (input[[1]]=="list" || input[[1]]=="c")){
    return(paste0(lapply(tail(as.list(input),-1L), deparse.clean)));
   }
  
  # formula
  if (class(input) == "formula"){
    if (length(input) == 2){
      return(deparse.clean(input[[2]]), width.cutoff=500L); # expression is ~ bla
    } else {
      return(deparse.clean(input[[3]]), width.cutoff=500L); # expression is x ~ bla, need bla
    }
  }

  # quoted expression
  if (is.call(input) || is.name(input)) {
    return(deparse.clean(input, width.cutoff=500L));
  }

  stop("Argument not recognized", deparse(input));
}

# auxiliary function to parse glas and transform into strings
# this function does not check the validity of GLAs
gla.normalize <- function(input) {
  numSymbs = length(input);
  # case 

  # case 1, GLA(name)
  if (numSymbs >= 2 && input[[1]] == 'GLA'){
    if (!is.symbol(input[[2]]))
      stop(paste("GLA name is deformed in ", deparse(input)));
    if (numSymbs == 2) # simple GLA
      return( paste("GLA:", deparse.clean(input[[2]]), sep=""));
    # templated gla
    # compute first recursively the arguments
    args <- lapply( input[3:numSymbs], gla.normalize );
    argsCol <- paste(args, sep=",", collapse=","); 
    return (paste("GLA:", deparse.clean(input[[2]]),
                  "<", argsCol, "> ", sep=""));
  }
  #case2, list of some kind
  if (length(input) >=2 && input[[1]] == 'alist'){
    return(paste("[", paste(lapply(eval(as.call(input)), gla.normalize), collapse=",")
                 , "]", sep=""));
  }
  # case 3, keep everythign the way it is
  return(deparse.clean(input));
}

#function to stop evaluation. Used to keep intact GLA, GF, GIST objects
#WARNING: the code is really hacked. Please do not change
keepIntact <- function(name, ...) {
  l=unquote(substitute(alist(...)));
  x=c(substitute(name));
  for(i in eval(l)) x<-c(x,i);
  return(as.call(x))
} 
# now define the symbols that stay the same
# exception is subexpressions guarded by .() which are evaluated
GLA <- function(...) keepIntact(GLA, ...);
UDF <- function(...) keepIntact(UDF, ...);
GF <- function(...) keepIntact(GF, ...);
GIST <- function(...) keepIntact(GIST, ...);

#function to greate GLA(...) in places where the above does not work
make.GLA <- function(name, ...){
  l <- list(...);
  return(as.call(c(quote(GLA),substitute(name),l)));
}


# generics for GLADE
# access an internal relation
setGeneric("read", function(.Object, relation, alias) standardGeneric("read"));
# like read but for data in external files
# format specifies the type of data. Default is "text"
setGeneric("readFrom", function(.Object, file, format, ...) standardGeneric("readFrom"));

# join two objects
# joinCond expresses the join condition
setGeneric("join", function(.Object1, listAtts1, .Object2, listAtts2) standardGeneric("join"));

# simple aggregate computation, use ??? for a more powerful one
setGeneric("aggregate", function(.Object, aggregate, exp, as) standardGeneric("aggregate"));

# GLA execution
# both inputs and outputs have to e alist(...)
setGeneric("gla", function(.Object, gla, inputs, outputs)
           standardGeneric("gla"));

# group input on groupAtts, compute aggregate for each group
# return result for each group
setGeneric("groupby", function(.Object, groupAtts, aggregate, aggInput, result)
           standardGeneric("groupby"));

# order tuples based on orderAtts, include extraAtts in result
# limit specifies max size of result
setGeneric("orderby", function(.Object, orderAtts, extraAtts, limit)
           standardGeneric("orderby"));

# obtain a list of available GLAs
setGeneric("list.GLAs", function(.Object) standardGeneric("list.GLAs"));

# usage info for GLA
setGeneric("describe.GLA", function(.Object, gla) standardGeneric("describe.GLA"));

# conversions from R objects to glade
as.glade <- function(.Object, x) {
  if (.Object@topObj != "NA"){
    stop("Relations can be accessed only starting with a fresh GLADE object");
  }

#  print("Class of x: " , class(x));
  if (!is.data.frame(x))
    x <- as.data.frame(x);

  # scan the table and determine the columns and types
  atts <- "";
  for (col in names(x)){
    type <- switch(class(x[,col]),
                   factor = "VARCHAR",
                   numeric = "DOUBLE",
                   character = "VARCHAR",
                   integer = "INT"
                   );
    att <- paste("\t", col, ":", type, sep="");
    if (atts!="")
      atts2 <- paste(atts, att, sep=",\n")
    else
      atts2 <- paste("\n", att, sep="");
    atts <- atts2;
  }
  
  # x is now a data.frame or this failed
  file <- glade.newName("Data_",".csv");
  write.csv(x, file, quote=FALSE, row.names=FALSE); # ,  col.names=FALSE);

  .Object@topObj <- glade.newName("data");
  statement1 <- paste("CREATE TEMP RELATION ", .Object@topObj, "(", atts, "\n);\n"
                      , sep="");
  statement2 <- paste(.Object@topObj, " = READ ", file, " ATTRIBUTES FROM ",
                      .Object@topObj, ";\n"
                      , sep="");
  .Object@piggy <- paste(statement1, statement2, sep="");
  return(.Object);
}

# constructor, server and user assumed set
setMethod("initialize", "glade",
          function(.Object, server, user) {
            # open connection to server
            .Object@server <- server;
            .Object@user <- user;
            .Object@topObj <- "NA"; #invalid
            
            # ask for schema

            .Object@piggy <- ""; # initialize

            return(.Object)
          });

setMethod("show", "glade",
          function(object) {
            cat("Server: ", object@server, "\n");
            cat("User: ", object@user, "\n");
            cat("Program:\n", object@piggy, "\n",sep="");
          });

setMethod("read", "glade",
          function(.Object, relation, alias=relation) {
            if (.Object@topObj != "NA"){
              stop("Relations can be accessed only starting with a fresh GLADE object");
            }
            relation <- glade.normalize(substitute(relation));# glade.normalize(relation);
            .Object@topObj <- relation;
            if (missing(alias)){
              statement <- paste("LOAD ", relation, ";\n",sep="");
            } else {
              alias <- glade.normalize(substitute(alias));
              statement <- paste(alias, " = LOAD ", relation, ";\n",sep="");
              
            }

            #test if relation is a relation
            .Object@piggy <- paste(.Object@piggy, statement, sep="");
            return(.Object)
          });

setMethod("join", "glade",
          function(.Object1, listAtts1, .Object2, listAtts2) {
            if (.Object1@topObj == "NA")
              stop("Left side of join has uninitialized object");

            if (.Object2@topObj == "NA")
              stop("Right side of join has uninitialized object");
            
            topObj <- glade.newName("join");
            statement <- paste(topObj, " = JOIN ",
                               .Object1@topObj, " BY ", glade.normalize(substitute(listAtts1)), ", ",
                               .Object2@topObj, " BY ", glade.normalize(substitute(listAtts2)), ";\n",
                               sep="");
            .Object1@piggy <- paste(.Object1@piggy, .Object2@piggy, statement,sep="");
            .Object1@topObj <- topObj;
            return(.Object1)
          });

setMethod("[", "glade",
          function(x, filter ) { # ugly but forced by [ signature
            if (x@topObj == "NA")
              stop("Argument of filter has uninitialized object");
            ## filter <- substitute(exp);
            ## print("fitler is");
            ## print(deparse(filter));
            
            topObj <- glade.newName("filter");
            statement <- paste(topObj, " = FILTER ",
                               x@topObj, " BY ", glade.normalize(substitute(filter)), ";\n",
                               sep="");
            x@piggy <- paste(x@piggy, statement,sep="");
            x@topObj <- topObj;
            
            
            return(x)
          });

setMethod("aggregate", "glade",
          function(.Object, aggregate, exp, as){
            if (.Object@topObj == "NA")
              stop("Argument of aggregate has uninitialized object");

            aggregate <-glade.normalize(substitute(aggregate));
            exp <- glade.normalize(substitute(exp));
            as <- glade.normalize(substitute(as));
            
            topObj <- glade.newName("agg");
            statement <- paste(topObj, " = AGGREGATE ", aggregate, " FROM ",
                               .Object@topObj, " USING ", exp , " AS ",
                               as, " ;\n",
                               sep="");
            .Object@piggy <- paste(.Object@piggy, statement,sep="");
            .Object@topObj <- topObj;
            
            return(.Object)
          });

# This function uses an ugly trick with global variables since
# .() does not seem to work with local variables
# WHY?? BUG IN R?
setMethod("groupby", "glade",
          function(.Object, groupAtts, aggregate, aggInput, result){
            if (.Object@topObj == "NA")
              stop("Argument of Group by has uninitialized object");

            groupAtts <- glade.normalize(substitute(groupAtts));
            aggInput <- glade.normalize(substitute(aggInput));
            gby_result_internal<<- glade.normalize(substitute(result));
            gby_inputs_internal <<- c(groupAtts, aggInput);
            aGLA <- aggregate;
            agg <- make.GLA(GroupByGLA, as.list(head(gby_result,n=length(groupAtts))),
                            aGLA);
            rez=gla(.Object, agg, .(gby_inputs), .(gby_result));
            rm("gby_result_internal", "gby_inputs_internal", envir=globalenv ());
            return(rez);
          });


#export the result as a data.frame
setMethod("as.data.frame", "glade",
          function(x, ...){
            args <- substitute(list(...));

            lrez <- lapply(args, glade.normalize);
            printBody <- "";
            printAS <- " AS ";
            for (var in names(lrez)){
              if (var == "") # fluke, some elements are ""
                next; 
              if ( printBody != ""){
                printBody <- paste0(printBody, ", ", lrez[[var]]);
                printAS <- paste0(printAS, ", ", var);
              } else {
                printBody <- args[[var]];
                printAS <- paste0(printAS, var);
              }
            }

            fileBase <- tempfile("Q", ".", "");
            pgyFile <- paste(fileBase, ".pgy", sep="");
            rezFile <- paste(fileBase, ".csv", sep="");
            
            printStmt <- paste("PRINT ", x@topObj, " USING ", printBody,
                               printAS, " INTO \"R-RESULT\" SEPARATOR \"|\" ;\n", sep="");
            x@piggy <- paste(x@piggy, printStmt, sep="");
            # writing the file
            cat(x@piggy, file=pgyFile);
            show(x);

            # no we run
            system(paste("./runPiggy.sh ", pgyFile, rezFile));
            rez <- read.csv(rezFile,sep="|");
            
            return(rez);
          });

# aux function to translate GLAs to strings
as.character.GLA <- function(x){
  if (missing(x))
    return("");

  if (is.character(x))
    return(x);
  
  if (is.call(x) && x[[1]]=="GLA"){
    name <- x[[2]];
    if(!is.symbol(name))
      stop("GLA's first argument is always the name");

    if( length(x) == 2)
      return(paste0("GLA:", name))
    else{
      rec <- lapply(tail(as.list(x),-2L), as.character.GLA);
      return(paste0("GLA:", deparse.clean(name),"< ", paste0(rec,collapse=", ")," >"))
    }
  }

  if (is.list(x)){
    return(
           paste0("[",
                  paste0(lapply(x, as.character.GLA), collapse=","),
                  "]"));
  }
  
  if (is.call(x) && (x[[1]]=="list" || x[[1]]=="c")){
    return(
           paste0("[",
                  paste0(lapply(tail(as.list(x),-1L), as.character.GLA),
                         collapse=","),
                  "]"));
  }

  if (is.language(x))
    return(deparse.clean(x));
  
  stop("Input to GLA not understood. Expression: ", deparse(x)," type:",typeof(x));
}


# gla method. inputs and outputs are expected to be lists with stopped evaluation (alist)
# or lists of parse trees list(..)
setMethod("gla", "glade",
          function(.Object, gla, inputs, outputs){
            if (.Object@topObj == "NA")
              stop("Argument of gla has uninitialized object");

            inputs <- glade.normalize(substitute(inputs));
            outputs <- glade.normalize(substitute(outputs));
                        
            inputs <- paste0(inputs, collapse=",");
            outputs <- paste0(outputs, collapse=",");
            
            topObj <- glade.newName("gla");
            statement <- paste0(topObj, " = ", as.character.GLA(gla), " FROM ",
                               .Object@topObj, " USING ", inputs, " AS ",
                               outputs, " ;\n");
            .Object@piggy <- paste0(.Object@piggy, statement);
            .Object@topObj <- topObj;
            
            return(.Object)
          });



# GLA construction support
